home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Language/OS - Multiplatform Resource Library
/
LANGUAGE OS.iso
/
lisp
/
clue.lha
/
clue
/
clx-patch.l
< prev
next >
Wrap
Lisp/Scheme
|
1989-07-12
|
4KB
|
113 lines
;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Patch-file:T -*-
;;;
;;; TEXAS INSTRUMENTS INCORPORATED
;;; P.O. BOX 2909
;;; AUSTIN, TEXAS 78769
;;;
;;; Copyright (C) 1987 Texas Instruments Incorporated.
;;;
;;; Permission is granted to any individual or institution to use, copy, modify,
;;; and distribute this software, provided that this complete copyright and
;;; permission notice is maintained, intact, in all copies and supporting
;;; documentation.
;;;
;;; Texas Instruments Incorporated provides this software "as is" without
;;; express or implied warranty.
;;;
;;; Written 08/24/87 16:09:09 by OREN,
;; Add an optional :WINDOW keyword parameter to create-window
(in-package 'xlib :use '(lisp))
; From file REQUESTS.LISP#> X.CLX; SI:
(defun create-window (&key
window
(parent (required-arg parent))
(x (required-arg x))
(y (required-arg y))
(width (required-arg width))
(height (required-arg height))
(depth 0) (border-width 0)
(class :copy) (visual :copy)
background border
bit-gravity gravity
backing-store backing-planes backing-pixel save-under
event-mask do-not-propagate-mask override-redirect
colormap cursor)
;; Display is obtained from parent. Only non-nil attributes are passed on in
;; the request: the function makes no assumptions about what the actual protocol
;; defaults are. Width and height are the inside size, excluding border.
(declare (type (or null window) window)
(type window parent) ; required
(type int16 x y) ;required
(type card16 width height) ;required
(type card16 depth border-width)
(type (member :copy :input-output :input-only) class)
(type (or (member :copy) card29) visual)
(type (or null (member :none :parent-relative) pixel pixmap) background)
(type (or null (member :copy) pixel pixmap) border)
(type (or null bit-gravity) bit-gravity)
(type (or null win-gravity) gravity)
(type (or null (member :not-useful :when-mapped :always)) backing-store)
(type (or null pixel) backing-planes backing-pixel)
(type (or null event-mask) event-mask)
(type (or null device-event-mask) do-not-propagate-mask)
(type (or null (member :on :off)) save-under override-redirect)
(type (or null (member :copy) colormap) colormap)
(type (or null (member :none) cursor) cursor))
(declare-values window)
(let* ((display (window-display parent))
(window (or window (make-window)))
(wid (allocate-resource-id display window 'window))
back-pixmap back-pixel
border-pixmap border-pixel)
(setf (window-id window) wid
(window-display window) display)
(case background
((nil) nil)
(:none (setq back-pixmap 0))
(:parent-relative (setq back-pixmap 1))
(otherwise
(if (type? background 'pixmap)
(setq back-pixmap (pixmap-id background))
(if (integerp background)
(setq back-pixel background)
(x-type-error background
'(or null (member :none :parent-relative) integer pixmap))))))
(case border
((nil) nil)
(:copy (setq border-pixmap 1))
(otherwise
(if (type? border 'pixmap)
(setq border-pixmap (pixmap-id border))
(if (integerp border)
(setq border-pixel border)
(x-type-error border '(or null (member :copy) integer pixmap))))))
(when event-mask
(setq event-mask (encode-event-mask event-mask)))
(when do-not-propagate-mask
(setq do-not-propagate-mask (encode-device-event-mask do-not-propagate-mask)))
;Make the request
(with-buffer-request (display *x-createwindow*)
(data depth)
(resource-id wid)
(window parent)
(int16 x y)
(card16 width height border-width)
((member16 :copy :input-output :input-only) class)
(resource-id (if (eq visual :copy) 0 visual))
(mask ((or null card32) back-pixmap back-pixel border-pixmap border-pixel)
((or null (member-vector *bit-gravity-vector*)) bit-gravity)
((or null (member-vector *win-gravity-vector*)) gravity)
((or null (member :not-useful :when-mapped :always)) backing-store)
((or null card32) backing-planes backing-pixel)
((or null (member :off :on)) override-redirect save-under)
((or null card32) event-mask do-not-propagate-mask)
((or null (member %error :copy) colormap) colormap)
((or null (member :none) cursor) cursor)))
window))